home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / programr / wtj208.zip / ZEMPEL / SOURCE / THUNKVB / VBARRAY.TXT < prev   
Text File  |  1993-05-08  |  4KB  |  125 lines
  1. Option Base 1
  2. Dim bigArray&()
  3. Dim NumElements&, ValElement&, ArrSize&
  4. Dim hVBArray%, arraycreated%
  5.  
  6. Sub cmdMakeArray_Click ()
  7.  
  8. 'this sub redimensions and fills a VB array
  9. 'then gets array linear addresses
  10. On Error GoTo OutofMem
  11. If (NumElements& * 4) > 15000000 Then
  12.     MsgBox "The array you requested is more than 15 MB, forget it", 16, "You must have a lot of memory!"
  13.     arraycreated% = 0
  14.     txAnswer = ""
  15.     Exit Sub
  16. ElseIf (NumElements& * 4) > 999999 Then
  17.     user% = MsgBox("This array is between 1 and 15 MB", 65, "Make Big VB Array?")
  18.     If (user% = 2) Then Exit Sub
  19. End If
  20.  
  21. If (NumElements& < 15999) Then
  22.      ArrSize& = NumElements& + 2
  23.      ArrColumns& = ArrSize&
  24.      ArrayRows& = 1&
  25.      ReDim bigArray&(1 To ArrColumns&, 1 To ArrayRows&)
  26. Else
  27.      ArrayRows& = (NumElements& / 16000&) + 1
  28.      ArrSize& = NumElements& + 2&
  29.      ArrColumns& = 16000&
  30.      ReDim bigArray&(1 To ArrColumns&, 1 To ArrayRows&)
  31. End If
  32. On Error GoTo 0                 'turns off error handling
  33.  
  34. For Y = 1 To ArrayRows&                     'fills array with value
  35.     For X = 1 To (ArrColumns&)              'if overs 64000 bytes,
  36.     bigArray&(X, Y) = ValElement&           'fills memory in 16,000 byte blocks
  37.     Next X
  38. Next Y
  39.  
  40. 'This is the key code:fixing linear virtual address of VB array
  41.  
  42. lpVBArray& = VBPTRtoLong(bigArray&(1, 1))   'must get pointer to first element
  43. VBSel% = lpVBArray& \ &H10000               'get selector from pointer
  44. lhvbarray& = GlobalHandle(VBSel%)           'get handle from selector
  45. hVBArray% = VBLowWord(lhvbarray&)           'handle is in the low word
  46. GlobalFix (hVBArray%)                       'fix VB array in virtual space
  47. Win31Linear& = GetSelectorBase(VBSel%)      'Win 3.1 function to get Windows3.1 linear address
  48. UTAddress& = UTSelectorOffSetToLinear(lpVBArray&) 'UT function to get WIn32s linear address from pointer
  49. GlobalUnFix (hVBArray%)                     'must unfix VB Array
  50.  
  51. 'must convert long to equivalent of dword (unsigned long int) and correct for offset of first element from selector start
  52. VBLinearAddress# = CDbl(Win31Linear&)
  53. If (VBLinearAddress# > 0) And ((ArrSize& * 4) > 65534) Then VBLinearAddress# = 9 + VBLinearAddress#   'VB arrays do not start at the selectors
  54. If (VBLinearAddress# > 0) And ((ArrSize& * 4) < 65535) Then VBLinearAddress# = 7 + VBLinearAddress#   'large (huge) arrays are offset an additional
  55.                                                       'two bytes
  56. If (VBLinearAddress# < 0) And ((ArrSize& * 4) > 65534) Then VBLinearAddress# = 4294967305# + VBLinearAddress#   'same conversion for >2GB virtual addresses
  57. If (VBLinearAddress# < 0) And ((ArrSize& * 4) < 65535) Then VBLinearAddress# = 4294967303# + VBLinearAddress#
  58.  
  59. VBUTAddress# = CDbl(UTAddress&)
  60. If (VBUTAddress# < 0) Then VBUTAddress# = 4294967296# + VBUTAddress#     'long to unsigned long int (equivalent) conversion for Win32s address
  61.  
  62.  
  63. OffSet# = VBUTAddress# - VBLinearAddress#   'compare Win32s address with Win3.1
  64.  
  65. txVBHandle.Text = Format$(hVBArray%)
  66. txVBLinear.Text = Format$(VBLinearAddress#)
  67. txVBUT.Text = Format$(VBUTAddress#)
  68. txOffset.Text = Format$(OffSet#)
  69. arraycreated% = 1
  70. txAnswer = ""
  71. Leavesub:
  72. Exit Sub
  73.  
  74. OutofMem:
  75.     If (Err = 7) Then
  76.     MsgBox "Out of memory, reduce size of array", 16, "Array too big"
  77.     arraycreated% = 0
  78.     Else MsgBox "undefined error"
  79.     End If
  80.     Unload frmVBArray
  81.     Resume Leavesub
  82. End Sub
  83.  
  84. Sub cmdSumArray_Click ()
  85.  
  86. 'summming the array in a win32 function from VB
  87. If arraycreated% = 0 Then
  88.     MsgBox "Redim Array first", 48
  89.     Exit Sub
  90. End If
  91. lpVBArray& = VBPTRtoLong&(bigArray&(1, 1))  'get pointer to first element
  92. VBSel% = lpVBArray& \ &H10000               'get selector from pointer
  93. lhvbarray& = GlobalHandle(VBSel%)
  94. hVBArray% = VBLowWord(lhvbarray&)
  95. bigArray&(1, 1) = NumElements&
  96. GlobalFix (hVBArray%)
  97.  
  98. 'calling 32 bit function through UT
  99. temp& = SumArray32(bigArray&(1, 1))
  100. GlobalUnFix (hVBArray%)
  101.  
  102. Sum2& = bigArray&(2, 1)
  103. txAnswer.Text = Format$(Sum2&)
  104. End Sub
  105.  
  106.  
  107. Sub Form_Load ()
  108. txNumElemts.Text = Format$(10000)
  109. txValElemt.Text = Format$(100)
  110.  
  111. End Sub
  112.  
  113. Sub txNumElemts_Change ()
  114. NumElements& = Val(txNumElemts.Text)
  115. If NumElements& < 1 Then
  116.     MsgBox "enter a number >0", 0, "Array size"
  117.     NumElements& = 10000
  118. End If
  119. End Sub
  120.  
  121. Sub txValElemt_Change ()
  122. ValElement& = Val(txValElemt.Text)
  123. End Sub
  124.  
  125.